home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / TSPA3450 / TSUNTENV.TST < prev    next >
Text File  |  1993-07-23  |  4KB  |  161 lines
  1. {$M 16384,0,0}
  2. {$R+}
  3.  
  4. program tsuntenvTest;
  5.  
  6. uses Dos,
  7.      TSUNTENV,
  8.      TSUNTE;     (* To include the routine getting the command line *)
  9.  
  10. procedure LOGO;
  11. begin
  12.   writeln;
  13.   writeln ('TSUNTENV unit test by Prof. Timo Salmi, 23-Jul-93');
  14.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  15. {$IFDEF VER40}
  16.   writeln ('TP version 4.0');
  17. {$ENDIF}
  18. {$IFDEF VER50}
  19.   writeln ('TP version 5.0');
  20. {$ENDIF}
  21. {$IFDEF VER55}
  22.   writeln ('TP version 5.5');
  23. {$ENDIF}
  24. {$IFDEF VER60}
  25.   writeln ('TP version 6.0');
  26. {$ENDIF}
  27. {$IFDEF VER70}
  28.   writeln ('TP version 7.0');
  29. {$ENDIF}
  30.   writeln;
  31. end;  (* logo *)
  32.  
  33. function HEXFN (decimal : word) : string;
  34. const hexDigit : array [0..15] of char = '0123456789ABCDEF';
  35. begin
  36.   hexfn := hexDigit[(decimal shr 12)]
  37.         + hexDigit[(decimal shr 8) and $0F]
  38.         + hexDigit[(decimal shr 4) and $0F]
  39.         + hexDigit[(decimal and $0F)];
  40. end;  (* hexfn *)
  41.  
  42. (* Demonstrate some information about the parent environment *)
  43. procedure TEST1;
  44. var envsize : word;
  45.     envuse  : word;
  46.     envaddr : string;
  47. begin
  48.   envsize := ENVSIZFN;
  49.   writeln ('The environment size is ', envsize:5, ' bytes');
  50.   envuse := ENVUSEFN;
  51.   writeln ('The environment use  is ', envuse:5, ' bytes');
  52.   envaddr := '$' + HEXFN(ENVADDFN);
  53.   writeln ('The environment segment address is ', envaddr);
  54.   SHOWENV;
  55. end;  (* test1 *)
  56.  
  57. (* Don't run the test from within the IDE *)
  58. procedure TEST2;
  59. var status : byte;
  60.     newset : string;
  61. begin
  62.   newset := copy (CMDLNFN, 2, 255);           (* From TSUNTE *)
  63.   if newset <> '' then
  64.     begin
  65.       SETENV (newset, status);
  66.       case status of
  67.         0 : writeln ('No errors detected');
  68.         1 : writeln ('Syntax error (Usage: variable=value)', #7);
  69.         2 : writeln ('Out of environment space', #7);
  70.         3 : writeln ('Missed the variable or the environment', #7);
  71.       end;
  72.     end
  73.   else
  74.     writeln ('Usage: TSUNTENV.EXE name=value');
  75. end;  (* test2 *)
  76.  
  77. (* Test setting the environment variable for the duration of shelling
  78.    to MsDos *)
  79. (* Don't run the test from within the IDE *)
  80. procedure TEST3;
  81. var comspec : string;
  82.     error   : integer;
  83. begin
  84.   {}
  85.   comspec := GetEnv ('comspec');
  86.   SETENVSH ('TEST_LONG_ENVIRONMENT', 'testing_the_environment');
  87.   SETENVSH ('PROMPT', '$p$g[SHELLED] ');
  88.   {}
  89.   writeln ('Type EXIT to return to TSUNTENV');
  90.   writeln ('Write SET to see the current environment variable values');
  91.   swapvectors;
  92.   Exec (comspec, '');   {execute the DOS shell}
  93.   swapvectors;
  94.   {}
  95.   error := DosError;
  96.   if error <> 0 then
  97.     begin
  98.       writeln ('Cannot run MsDos shell');
  99.       if error = 8 then
  100.          writeln ('Out of memory')
  101.        else
  102.          writeln ('Command processor ', comspec, ' not found');
  103.       halt;
  104.     end;
  105.   {}
  106.   writeln ('Back from shell');
  107.   writeln ('Write SET to see the current environment variable values');
  108. end;  (* test3 *)
  109.  
  110. (* Test setting several values at one go.
  111.    This is quite complicated, since you have to trick the program
  112.    by inserting the previous new values for the duration of the
  113.    unit's external shell.  Here is how it goes:
  114. (* Don't run these tests from within the IDE *)
  115. procedure TEST4;
  116. const n = 2;
  117. var newset : array [1..n] of string;
  118.     i      : integer;
  119.     p      : byte;
  120.     status : byte;
  121. begin
  122.   newset[1] := 'TEST1=TESTVALUE1';
  123.   newset[2] := 'TEST2=TESTVALUE2';
  124.   for i := 1 to n do
  125.     begin
  126.      if newset[i] <> '' then
  127.        begin
  128.          {... Carefully note this trick to allow more than one set ...}
  129.          if i > 1 then
  130.            begin
  131.              p := Pos ('=', newset[i-1]);
  132.              SETENVSH (Copy(newset[i-1],1,p-1), Copy(newset[i-1],p+1,255));
  133.            end;
  134.          {}
  135.          SETENV (newset[i], status);
  136.            case status of
  137.              0 : writeln ('No errors detected');
  138.              1 : writeln ('Syntax error (Usage: variable=value)', #7);
  139.              2 : writeln ('Out of environment space', #7);
  140.              3 : writeln ('Missed the variable or the environment', #7);
  141.            end;
  142.        end
  143.      else
  144.        writeln ('Usage: TSUNTENV.EXE name=value');
  145.     end;  {for}
  146. end;  (* test4 *)
  147.  
  148. (* Main program *)
  149. (* Don't run these tests from within the IDE *)
  150. begin
  151.   LOGO;
  152.   {
  153.   TEST3;
  154.   TEST1;
  155.   }
  156.   TEST4;
  157.   TEST1;
  158.   {}
  159.   { write ('Press <-'' '); readln; }
  160. end.  (* tsuntenv.tst *)
  161.